home *** CD-ROM | disk | FTP | other *** search
/ Precision Software Appli…tions Silver Collection 1 / Precision Software Applications Silver Collection Volume One (PSM) (1993).iso / windows / games / wlpep111.arj / WALLMODL.BAS < prev    next >
BASIC Source File  |  1992-12-15  |  11KB  |  349 lines
  1. Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
  2. Global Const WM_USER = &H400
  3. Global Const LB_RESETCONTENT = WM_USER + 5
  4. Global Const PIXEL = 3
  5.  
  6. Sub AddNames (I As Integer)
  7.     Form1.File2.Path = Form1.Dir2.List(I)
  8.     For J = 0 To Form1.File2.ListCount - 1
  9.         Form1.List1.AddItem Form1.File2.List(J) + Chr$(9) + Chr$(9) + Format$(Dirs)
  10.     Next J
  11. End Sub
  12.  
  13. Sub CallUpPBrush (DName$, FName$)
  14. If Right$(DName$, 1) <> "\" Then DName$ = DName$ + "\"
  15. OldMousePointer = Screen.MousePointer
  16. Screen.MousePointer = 11
  17. If (form2.DestinationPic.ScaleWidth <> Form1.Picture1.ScaleWidth) Or (form2.DestinationPic.ScaleHeight <> Form1.Picture1.ScaleHeight) Then
  18.    Resp% = MsgBox("Do you want to start Paintbrush with the scaled image in the clipboard ready for pasting to create a new file?", 32 + 4)
  19.    If Resp% = 6 Then
  20.       Clipboard.Clear
  21.       Clipboard.SetData form2.DestinationPic.Image
  22.       T% = Shell("pbrush", 1)
  23.       Screen.MousePointer = OldMousePointer
  24.       Exit Sub
  25.    End If
  26. End If
  27. If (Right$(FName$, 4) <> ".bmp") Then
  28.    Resp% = MsgBox(UCase$(FName$) + " is not a .BMP file and can't be directly changed in Paintbrush." + Chr$(13) + Chr$(13) + "Do you want to start Paintbrush with the image in the clipboard ready for pasting to create a new file?", 32 + 4)
  29.    If Resp% = 6 Then
  30.       Clipboard.Clear
  31.       Clipboard.SetData Form1.Picture1.Image
  32.       T% = Shell("pbrush", 1)
  33.    End If
  34.    'MsgBox "Sorry!  Not a BMP file."
  35. Else
  36.    T% = Shell("pbrush " + DName$ + FName$, 1)
  37. End If
  38. Screen.MousePointer = OldMousePointer
  39.  
  40. End Sub
  41.  
  42. Sub ClearListBox (Ctrl As Control)
  43.   hWndOld% = GetFocus()
  44.   tempE% = Ctrl.Enabled
  45.   tempV% = Ctrl.Visible
  46.   Ctrl.Enabled = True
  47.   Ctrl.Visible = True
  48.  
  49.   Ctrl.SetFocus
  50.   X = SendMessage(GetFocus(), LB_RESETCONTENT, 0, 0&)
  51.   Ctrl.Enabled = tempE%
  52.   Ctrl.Visible = tempV%
  53.   Suc% = PutFocus(hWndOld%)
  54. End Sub
  55.  
  56. Sub DottedLine ()
  57. form2.DestinationPic.DrawStyle = 0
  58. form2.DestinationPic.DrawMode = 13
  59. form2.DestinationPic.DrawWidth = 1
  60.  
  61. form2.DestinationPic.ForeColor = &HFFFFFF
  62. form2.DestinationPic.Line (0, 0)-(form2.DestinationPic.Width - 3, 0)
  63. form2.DestinationPic.Line (form2.DestinationPic.Width - 3, 0)-(form2.DestinationPic.Width - 3, form2.DestinationPic.Height - 3)
  64. form2.DestinationPic.Line (0, form2.DestinationPic.Height - 3)-(form2.DestinationPic.Width - 3, form2.DestinationPic.Height - 3)
  65. form2.DestinationPic.Line (0, 0)-(0, form2.DestinationPic.Height - 3)
  66.  
  67.  
  68. form2.DestinationPic.DrawStyle = 2
  69. form2.DestinationPic.ForeColor = 0
  70. form2.DestinationPic.Line (0, 0)-(form2.DestinationPic.Width - 3, 0)
  71. form2.DestinationPic.Line (form2.DestinationPic.Width - 3, 0)-(form2.DestinationPic.Width - 3, form2.DestinationPic.Height - 3)
  72. form2.DestinationPic.Line (0, form2.DestinationPic.Height - 3)-(form2.DestinationPic.Width - 3, form2.DestinationPic.Height - 3)
  73. form2.DestinationPic.Line (0, 0)-(0, form2.DestinationPic.Height - 3)
  74. End Sub
  75.  
  76. Sub DragPictureTo (X As Integer, Y As Integer, Shift As Integer)
  77. If gDrawing Then Exit Sub
  78. gDrawing = True
  79.  
  80. dwRop& = &HCC0020
  81. If Form1.TileChecked.Value Then
  82.    Tiling = True
  83. Else
  84.    Tiling = False
  85. End If
  86.  
  87. 'to dest from source
  88. If Shift Then
  89.   Ratio = Form1.Picture1.Width / Form1.Picture1.Height
  90.   If X < Ratio * Y Then Y = X / Ratio
  91.   If Ratio * Y < X Then X = Y * Ratio
  92. End If
  93.  
  94. If X < 6 Then X = 6
  95. If Y < 6 Then Y = 6
  96. 'If Not Tiling Then
  97. '   dX = (X - Form2.DestinationPic.Width) \ 2
  98. '   dY = (Y - Form2.DestinationPic.Height) \ 2
  99. '   Form2.DestinationPic.Width = Form2.DestinationPic.Width + dX * 2
  100. '   Form2.DestinationPic.Left = Form2.DestinationPic.Left - dX
  101. '   Form2.DestinationPic.Height = Form2.DestinationPic.Height + dY * 2
  102. '   Form2.DestinationPic.Top = Form2.DestinationPic.Top - dY
  103. 'Else
  104.    form2.DestinationPic.Width = X
  105.    form2.DestinationPic.Height = Y
  106. 'End If
  107.  
  108. If Metafile Then
  109.    form2.DestinationPic.AutoSize = False
  110.    form2.DestinationPic.Picture = Form1.Picture1.Picture
  111. Else
  112.    T% = DoEvents()
  113.    T% = StretchBlt%(form2.DestinationPic.hDC, 0, 0, X - 1, Y - 1, Form1.Picture1.hDC, 0, 0, Form1.Picture1.Width, Form1.Picture1.Height, dwRop&)
  114.    T% = DoEvents()
  115. End If
  116. 'Form1.Picture1.Width = Form2.DestinationPic.Width
  117. 'Form1.Picture1.Height = Form2.DestinationPic.Height
  118. 'Form1.Picture1.ScaleWidth = Form2.DestinationPic.ScaleWidth
  119. 'Form1.Picture1.ScaleHeight = Form2.DestinationPic.ScaleHeight
  120. 'T% = BitBlt%(Form2.DestinationPic.hDC, Form2.DestinationPic.Left, Form2.DestinationPic.Top, X, Y, Form1.Picture1.hDC, Form1.Picture1.Left, Form1.Picture1.Top, dwRop&)
  121. gDrawing = False
  122. End Sub
  123.  
  124. Sub File1DClick ()
  125. DName$ = Form1.File1.Path
  126. Call CallUpPBrush(DName$, (Form1.File1.FileName))
  127. End Sub
  128.  
  129. Sub FillList ()
  130. Form1.Command2.Visible = False
  131. Form1.Label1.Visible = True
  132. ClearListBox Form1.List1
  133.  
  134. On Error Resume Next
  135. Form1.Dir2.Path = Form1.Drive1.Drive + "\"
  136. If Err <> 0 Then
  137.    On Error Resume Next
  138.    Form1.Drive1.Drive = SavedDrive$
  139.    Form1.Dir2.Path = SavedDrive$ + "\"
  140. End If
  141. On Error GoTo 0
  142. SavedDrive$ = Form1.Drive1.Drive
  143. Dirs = 1
  144. DirName(Dirs) = Form1.Dir2.Path
  145. AddNames (-1)    'was 1
  146. CheckingDir = 0
  147. While CheckingDir < Dirs
  148.    If CheckingDir Mod 10 = 0 Then
  149.       Form1.Label1.Caption = Format$(CheckingDir) + " / " + Format$(Dirs)
  150.       T% = DoEvents()
  151.    End If
  152.    CheckingDir = CheckingDir + 1
  153.    On Error Resume Next
  154.    Form1.Dir2.Path = DirName(CheckingDir)
  155.    On Error GoTo 0
  156.    For I = 0 To Form1.Dir2.ListCount - 1
  157.       Dirs = Dirs + 1
  158.       DirName(Dirs) = Form1.Dir2.List(I)
  159.       AddNames (I)
  160.    Next I
  161.  
  162. Wend
  163.  
  164.  
  165. Form1.Label1.Caption = ""
  166. Form1.Label1.Visible = False
  167. Form1.Command2.Enabled = False
  168. Form1.Command2.Visible = True
  169. If Form1.List1.ListCount > 0 Then Form1.List1.ListIndex = 0
  170.  
  171. End Sub
  172.  
  173. Function FindItem (Lst As Control, a$) As Integer
  174. Dim U As Integer
  175. Dim L As Integer
  176. Dim I As Integer
  177. U = Lst.ListCount
  178. L = 0
  179. I = 0
  180. If U = 0 Then
  181.    FindItem = -1
  182.    Exit Function
  183. End If
  184. Do
  185.    If U < L Then
  186.       'Lst.ListIndex = I + 1'set .ListIndex to nearest match
  187.       FindItem = -1
  188.       Exit Function
  189.    End If
  190.  
  191.    I = (L + U) / 2
  192.    If a$ = Lst.List(I) Then
  193.       Lst.ListIndex = I  'Found. Set ".ListIndex" accordingly
  194.       FindItem = I
  195.       Exit Function
  196.    Else
  197.       If a$ > Lst.List(I) Then
  198.          L = I + 1
  199.       Else
  200.          U = I - 1
  201.       End If
  202.    End If
  203. Loop
  204. End Function
  205.  
  206. Sub GetBackgroundColor ()
  207.    lpDefault$ = "0 0 0" + String$(256, " ")
  208.    lpRS$ = "0 0 0" + String$(256, " ")
  209.    T% = GetProfileString%("colors", "Background", lpDefault$, lpRS$, 256)
  210.    SP1Pos = InStr(lpRS$, " ")
  211.    R$ = Left$(lpRS$, SP1Pos - 1)
  212.    GB$ = Mid$(lpRS$, SP1Pos + 1, 255)
  213.    SP1Pos = InStr(GB$, " ")
  214.    G$ = Left$(GB$, SP1Pos - 1)
  215.    B$ = Mid$(GB$, SP1Pos + 1, 255)
  216.    bgCol& = RGB(Val(R$), Val(G$), Val(B$))
  217.    form2.BackColor = bgCol&
  218.  
  219. End Sub
  220.  
  221. Sub GetNameAndDir (T$, FName$, DName$)
  222. FName$ = Left$(T$, InStr(T$, Chr$(9)) - 1)
  223. DName$ = DirName(Val(Mid$(T$, InStr(T$, Chr$(9)) + 2, 255)))
  224. 'If Right$(DName$, 1) <> "\" Then DName$ = DName$ + "\"
  225. End Sub
  226.  
  227. Sub List1DClick ()
  228. Call GetNameAndDir((Form1.List1.List(Form1.List1.ListIndex)), FName$, DName$)
  229. Call CallUpPBrush(DName$, FName$)
  230. End Sub
  231.  
  232. Sub PositionOutline ()
  233. If Form1.ResizableChecked.Value Then
  234.    form2.DestinationPic.Left = LBWidth% - 1
  235.    form2.DestinationPic.Top = LBHeight% - 1
  236.    form2.DestinationPic.BorderStyle = 1
  237. Else
  238.    form2.DestinationPic.BorderStyle = 0
  239. End If
  240. form2.Picture1.Left = form2.DestinationPic.Width - form2.Picture1.Width + form2.DestinationPic.Left
  241. form2.Picture1.Top = form2.DestinationPic.Height - form2.Picture1.Height + form2.DestinationPic.Top
  242. 'Form2.DestinationPic.Line (0, 0)-(Form2.DestinationPic.Width, 0)
  243. 'Beep
  244. 'Form2.Line x
  245. '
  246. 'Form2.DestinationPic.BorderStyle = 0
  247. End Sub
  248.  
  249. Sub ShowPicture (D$, F$)
  250. Form1.Picture1.AutoRedraw = True
  251. Form1.Picture1.Cls
  252. form2.DestinationPic.AutoRedraw = True
  253. form2.DestinationPic.Cls
  254. On Error Resume Next
  255. If Right$(D$, 1) = "\" Then
  256.    Form1.Picture1.Picture = LoadPicture(D$ + F$)
  257. Else
  258.    Form1.Picture1.Picture = LoadPicture(D$ + "\" + F$)
  259. End If
  260. If Right$(F$, 4) = ".wmf" Then
  261.    Metafile = True
  262. Else
  263.    Metafile = False
  264. End If
  265.  
  266. If Err <> 0 Then MsgBox "Can't load that picture."
  267. On Error GoTo 0
  268. form2.DestinationPic.AutoSize = True
  269. form2.DestinationPic.Picture = Form1.Picture1.Picture
  270. form2.DestinationPic.AutoSize = False
  271. T% = DoEvents()
  272. form2.Picture1.Left = form2.DestinationPic.Width - form2.Picture1.Width + form2.DestinationPic.Left
  273. form2.Picture1.Top = form2.DestinationPic.Height - form2.Picture1.Height + form2.DestinationPic.Top
  274. 'Form2.DestinationPic.Line (0, 0)-(Form2.DestinationPic.Width, 0)
  275. 'Beep
  276. 'Call DottedLine
  277. End Sub
  278.  
  279. Sub WallPaper ()
  280.  
  281. OldMousePointer = Screen.MousePointer
  282. Screen.MousePointer = 11
  283.  
  284. 'Assign information of the destination bitmap. Note that BitBlt() requires coordinates in pixels.
  285.  
  286. form2.DestinationPic.ScaleMode = PIXEL
  287. form2.ScaleMode = PIXEL
  288. nWidth% = form2.DestinationPic.ScaleWidth
  289. nHeight% = form2.DestinationPic.ScaleHeight
  290.  
  291. 'Assign information of the source bitmap.
  292. hSrcDC% = form2.DestinationPic.hDC
  293. XSrc% = 0: YSrc% = 0
  294.  
  295. 'Assign the SRCCOPY constant to the raster operation.
  296. dwRop& = &HCC0020
  297. HorzCenter% = form2.ScaleWidth / 2
  298. VertCenter% = form2.ScaleHeight / 2
  299. If Form1.TileChecked.Value = 0 Then
  300.    LBWidth% = HorzCenter% - nWidth% / 2
  301.    LBHeight% = VertCenter% - nHeight% / 2
  302.    UBWidth% = HorzCenter% + nWidth% / 2 - 1
  303.    UBHeight% = VertCenter% + nHeight% / 2 - 1
  304.    
  305.    form2.ForeColor = form2.BackColor
  306.  
  307.    hDestDC% = form2.hDC
  308.    form2.FillColor = form2.BackColor
  309.    Suc% = PatBlt(hDestDC%, 0, 0, form2.ScaleWidth, form2.ScaleHeight, &HF00021)
  310.    form2.DestinationPic.Left = LBWidth%
  311.    form2.DestinationPic.Top = LBHeight%
  312. Else
  313.    LBWidth% = 0
  314.    LBHeight% = 0
  315.    UBWidth% = form2.ScaleWidth
  316.    UBHeight% = form2.ScaleHeight
  317. 'End If
  318.  
  319. X% = LBWidth%
  320. Y% = LBHeight%
  321. For I% = 1 To 1
  322.    If I% = 1 Then
  323.       form2.AutoRedraw = -1
  324.       hDestDC% = form2.hDC
  325.    Else
  326.       form2.AutoRedraw = -1
  327.       hDestDC% = form2.hDC
  328.    End If
  329.    If (nHeight% > 0) And (nWidth% > 0) Then
  330.       While Y% < UBHeight%
  331.          While X% < UBWidth%
  332.          Suc% = BitBlt(hDestDC%, X%, Y%, nWidth%, nHeight%, hSrcDC%, XSrc%, YSrc%, dwRop&)
  333.          X% = X% + nWidth%
  334.          Wend
  335.          X% = LBWidth%
  336.          Y% = Y% + nHeight%
  337.       Wend
  338.    Else
  339.       form2.Cls
  340.       form2.Print "?!"
  341.    End If
  342. Next I%
  343. End If
  344.  
  345. form2.Refresh
  346. Screen.MousePointer = OldMousePointer
  347. End Sub
  348.  
  349.